home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpc09905c.lha / fpc / inc / real2str.inc < prev    next >
Text File  |  1998-09-21  |  6KB  |  234 lines
  1. {
  2.     $Id: real2str.inc,v 1.10 1998/08/11 21:39:06 peter Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1997 by Michael Van Canneyt,
  5.     member of the Free Pascal development team
  6.  
  7.     See the file COPYING.FPC, included in this distribution,
  8.     for details about the copyright.
  9.  
  10.     This program is distributed in the hope that it will be useful,
  11.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  
  14.  **********************************************************************}
  15.  
  16. type
  17.  
  18.   treal_type = (rt_s64real,rt_s32real,rt_f32bit,rt_s80real,rt_s64bit);
  19.   { corresponding to real    single     fixed   extended and comp for i386 }
  20.  
  21. {$ifdef i386}
  22.   {$ifdef DEFAULT_EXTENDED}
  23.     bestreal = extended;
  24.   {$else}
  25.     bestreal = double;
  26.   {$endif DEFAULT_EXTENDED}
  27. {$else i386}
  28.   bestreal = single;
  29. {$endif i386}
  30.  
  31. Procedure str_real (len,f : longint; d : bestreal; real_type :treal_type; var s : string);
  32. {
  33.   These numbers are for the double type...
  34.   At the moment these are mapped onto a double but this may change
  35.   in the future !
  36. }
  37. var  maxlen : longint;   { Maximal length of string for float }
  38.      minlen : longint;   { Minimal length of string for float }
  39.      explen : longint;   { Length of exponent, including E and sign.
  40.                            Must be strictly larger than 2 }
  41. const
  42.       maxexp = 1e+35;   { Maximum value for decimal expressions }
  43.       minexp = 1e-35;   { Minimum value for decimal expressions }
  44.       zero   = '0000000000000000000000000000000000000000';
  45.  
  46. var correct : longint;  { Power correction }
  47.     currprec : longint;
  48.     roundcorr : bestreal;
  49.     temp : string;
  50.     power : string[10];
  51.     sign : boolean;
  52.     i : integer;
  53.     dot : byte;
  54.  
  55. begin
  56.   case real_type of
  57.     rt_s64real :
  58.       begin
  59.          maxlen:=23;
  60.          minlen:=9;
  61.          explen:=5;
  62.       end;
  63.     rt_s32real :
  64.       begin
  65.          maxlen:=16;
  66.          minlen:=8;
  67.          explen:=4;
  68.       end;
  69.     rt_f32bit  :
  70.       begin
  71.          maxlen:=16;
  72.          minlen:=8;
  73.          explen:=4;
  74.       end;
  75.     rt_s80real :
  76.       begin
  77.          maxlen:=26;
  78.          minlen:=10;
  79.          explen:=6;
  80.       end;
  81.     rt_s64bit  :
  82.       begin
  83.          maxlen:=22;
  84.          minlen:=9;
  85.          { according to TP (was 5) (FK) }
  86.          explen:=6;
  87.       end;
  88.     end;
  89.   { check parameters }
  90.   { default value for length is -32767 }
  91.   if len=-32767 then len:=maxlen;
  92.   { determine sign. before precision, needs 2 less calls to abs() }
  93.   sign:=d<0;
  94.   { the creates a cannot determine which overloaded function to call
  95.   if d is extended !!!
  96.   we should prefer real_to_real on real_to_longint !!
  97.   corrected in compiler }
  98.  
  99.   {  d:=abs(d); this converts d to double so we loose precision }
  100.   { for the same reason I converted d:=frac(d) to d:=d-int(d); (PM) }
  101.   if sign then d:=-d;
  102.   { determine precision : maximal precision is : }
  103.   currprec:=maxlen-explen-3;
  104.   { this is also the maximal number of decimals !!}
  105.   if f>currprec then f:=currprec;
  106.   { when doing a fixed-point, we need less characters.}
  107.   if (f<0) or ( (d<>0) and ((d>maxexp) or (d<minexp))) then
  108.     begin
  109.     { determine maximal number of decimals }
  110.     if (len>=0) and (len<minlen) then len:=minlen;
  111.     if (len>0) and (len<maxlen) then
  112.       currprec:=len-explen-3;
  113.     end;
  114.   { convert to standard form. }
  115.   correct:=0;
  116.   if d>=10.0 then
  117.     while d>=10.0 do
  118.       begin
  119.       d:=d/10.0;
  120.       inc(correct);
  121.       end
  122.   else if (d<1) and (d<>0) then
  123.     while d<1 do
  124.       begin
  125.       d:=d*10.0;
  126.       dec(correct);
  127.       end;
  128.   { RoundOff }
  129.   roundcorr:=0.5;
  130.   if f<0 then
  131.     for i:=1 to currprec do roundcorr:=roundcorr/10
  132.   else
  133.     for i:=1 to correct+f do roundcorr:=roundcorr/10;
  134.   d:=d+roundcorr;
  135.   { 0.99 + 0.05 > 10.0 ! Fix this by dividing the results >=10 first (PV) }
  136.   if d>=10.0 then
  137.    begin
  138.      d:=d/10.0;
  139.      inc(correct);
  140.    end;
  141.   { Now we have a standard expression : sign d *10^correct
  142.     where  1<d<10 or d=0 ... }
  143.   { get first character }
  144.   if sign then
  145.     temp:='-'
  146.   else
  147.     temp:=' ';
  148.   temp:=temp+chr(ord('0')+trunc(d));
  149.   d:=d-int(d);
  150.   { Start making the string }
  151.   for i:=1 to currprec do
  152.     begin
  153.     d:=d*10.0;
  154.     temp:=temp+chr(ord('0')+trunc(d));
  155.     d:=d-int(d);
  156.     end;
  157.   { Now we need two different schemes for the different
  158.     representations. }
  159.   if (f<0) or (correct>maxexp) then
  160.     begin
  161.     insert ('.',temp,3);
  162.     str(abs(correct),power);
  163.     if length(power)<explen-2 then
  164.       power:=copy(zero,1,explen-2-length(power))+power;
  165.     if correct<0 then power:='-'+power else power:='+'+power;
  166.     temp:=temp+'E'+power;
  167.     end
  168.   else
  169.     begin
  170.     if not sign then
  171.       begin
  172.       delete (temp,1,1);
  173.       dot:=2;
  174.       end
  175.     else
  176.       dot:=3;
  177.     { set zeroes and dot }
  178.     if correct>=0 then
  179.        begin
  180.        if length(temp)<correct+dot+f then
  181.          temp:=temp+copy(zero,1,correct+dot+f-length(temp));
  182.        insert ('.',temp,correct+dot);
  183.        end
  184.     else
  185.       begin
  186.       correct:=abs(correct);
  187.        insert(copy(zero,1,correct),temp,dot-1);
  188.        insert ('.',temp,dot);
  189.        end;
  190.     {correct length to fit precision.}
  191.       if f>0 then
  192.        temp[0]:=chr(pos('.',temp)+f)
  193.       else
  194.        temp[0]:=chr(pos('.',temp)-1);
  195.     end;
  196.   if length(temp)<len then
  197.     s:=space(len-length(temp))+temp
  198.   else
  199.     s:=temp;
  200. end;
  201.  
  202. {
  203.   $Log: real2str.inc,v $
  204.   Revision 1.10  1998/08/11 21:39:06  peter
  205.     * splitted default_extended from support_extended
  206.  
  207.   Revision 1.9  1998/08/11 00:05:25  peter
  208.     * $ifdef ver0_99_5 updates
  209.  
  210.   Revision 1.8  1998/08/10 15:56:30  peter
  211.     * fixed 0_9_5 typo
  212.  
  213.   Revision 1.7  1998/08/08 12:28:12  florian
  214.     * a lot small fixes to the extended data type work
  215.  
  216.   Revision 1.6  1998/07/18 17:14:22  florian
  217.     * strlenint type implemented
  218.  
  219.   Revision 1.5  1998/07/13 21:19:10  florian
  220.     * some problems with ansi string support fixed
  221.  
  222.   Revision 1.4  1998/06/18 08:15:33  michael
  223.   + Fixed error when printing zero. len was calculated wron.
  224.  
  225.   Revision 1.3  1998/05/12 10:42:45  peter
  226.     * moved getopts to inc/, all supported OS's need argc,argv exported
  227.     + strpas, strlen are now exported in the systemunit
  228.     * removed logs
  229.     * removed $ifdef ver_above
  230.  
  231.   Revision 1.2  1998/04/07 22:40:46  florian
  232.     * final fix of comp writing
  233. }
  234.